home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / archiver / extar10.zip / EXTAR.PAS < prev    next >
Pascal/Delphi Source File  |  1990-02-26  |  10KB  |  305 lines
  1. Program extar;
  2. { Extract from TAR file, correcting names to be acceptable for MS-DOS        }
  3. { No checking performed.                                                     }
  4. { FreeWare by TapirSoft Gisbert W.Selke, Feb 1990                            }
  5. {$A+,B-,D+,E+,F-,I-,L+,N-,O-,R-,S+,V- }
  6. {$M 16384,0,16384 }
  7.  
  8.   Uses Dos;
  9.  
  10.   Const progname = 'ExTAR';
  11.         version = '1.0';
  12.         copyright = 'FreeWare by TapirSoft Gisbert W.Selke, Feb 1990';
  13.         secsize = 512;
  14.         hdrlen = secsize;
  15.         secsperblock = 120;
  16.         bufsize = secsize * secsperblock;
  17.         CR = #13;
  18.  
  19.   Type buf = Array [0..Pred(bufsize)] Of byte;
  20.  
  21.   Var tar, outf : File;
  22.       tarname, outname : string;
  23.       buffer : buf;
  24.       dt : DateTime;
  25.       i : byte;
  26.       iread, ibuf, nbufs, nrest : word;
  27.       nsecs, memberlen, datestamp : longint;
  28.       finish : boolean;
  29.  
  30.   Function ReadKey : char;
  31.   { don't need CRT unit for this!                                            }
  32.     Inline(
  33.       $B4/$08/               { Mov ah, $08 }
  34.       $CD/$21);              { Int $21     }
  35.  
  36.   Procedure abort(msg : string; ierr : byte);
  37.   { display an error message and die with error code                         }
  38.   Begin                                                              { abort }
  39.     If IOResult <> 0 Then;
  40.     If msg <> '' Then writeln(progname,': ',msg);
  41.     Halt(ierr);
  42.   End;                                                               { abort }
  43.  
  44.   Procedure usage;
  45.   { give hints on usage and die                                              }
  46.   Begin                                                              { usage }
  47.     writeln('A simple programme to extract all members from a TAR file');
  48.     writeln('Usage: ',progname,' <tarfilename>');
  49.     abort('',1);
  50.   End;                                                               { usage }
  51.  
  52.   Procedure crackutime(datestamp : longint; Var dt : DateTime);
  53.   { extracts date and time from Unix time stamp, assuming TZ = GMT + 8       }
  54.     Const monlen : Array [1..12] Of byte =
  55.                                         (31,28,31,30,31,30,31,31,30,31,30,31);
  56.   Begin                                                         { crackutime }
  57.     With dt Do
  58.     Begin
  59.       datestamp := datestamp - 8*3600;
  60.       sec := datestamp Mod 60;
  61.       datestamp := datestamp Div 60;
  62.       min := datestamp Mod 60;
  63.       datestamp := datestamp Div 60;
  64.       hour:= datestamp Mod 24;
  65.       datestamp := datestamp Div 24;
  66.       year := 1970;
  67.       While datestamp > 0 Do
  68.       Begin
  69.         Inc(year);
  70.         If (year Mod 4) = 0 Then day := 366
  71.                             Else day := 365;
  72.         datestamp := datestamp - day;
  73.       End;
  74.       Dec(year);
  75.       day := datestamp + day + 1;
  76.       month := 1;
  77.       While day > monlen[month] Do
  78.       Begin
  79.         day := day - monlen[month];
  80.         If (month = 2) And ((year Mod 4) = 0) Then Dec(day);
  81.         Inc(month);
  82.       End;
  83.     End;
  84.   End;                                                          { crackutime }
  85.  
  86.   Procedure openfile(Var outname : string);
  87.   { make a name acceptable for DOS and open the file for output              }
  88.  
  89.     Const badletter : Set Of char = ['.','+',' ',':','<','>','|'];
  90.           yesset : Set Of char = ['Y','J','1'];
  91.           noset  : Set Of char = ['N','0'];
  92.  
  93.     Var i : byte;
  94.         ch : char;
  95.         temp, drive, dir, name, ext : string;
  96.         ok : boolean;
  97.  
  98.     Procedure makedirs(Var dir1 : string; dir2 : string);
  99.     { make a directory recursively, if necessary                             }
  100.       Var i : byte;
  101.           dire, temp : string;
  102.           sr : SearchRec;
  103.     Begin                                                         { makedirs }
  104.       If dir2 = '' Then Exit;
  105.       i := Pos('\',dir2);
  106.       temp := Copy(dir2,1,Pred(i));
  107.       Delete(dir2,1,i);
  108.       If temp[1] = '.' Then Delete(temp,1,1);
  109.       i := Pos('.',temp);
  110.       If i > 0 Then
  111.       Begin
  112.         dire := Copy(temp,Succ(i),255);
  113.         Delete(temp,i,255);
  114.       End
  115.         Else dire := '';
  116.       If Length(temp) > 8 Then
  117.       Begin
  118.         dire := Copy(temp,9,255);
  119.         Delete(temp,9,255);
  120.       End;
  121.       If Length(dire) > 3 Then Delete(dire,4,255);
  122.       If Pos('.',dire) > 0 Then Delete(dire,Pos('.',dire),255);
  123.       dir1 := dir1 + temp + '.' + dire;
  124.       FindFirst(dir1,directory,sr);
  125.       If DosError <> 0 Then
  126.       Begin
  127.         MkDir(dir1);
  128.         If IOResult <> 0 Then abort('Error making directory '+dir1,2);
  129.       End;
  130.       dir1 := dir1 + '\';
  131.       makedirs(dir1,dir2);
  132.     End;                                                          { makedirs }
  133.  
  134.     Procedure filesplit(path : string; Var drive, dir, name, ext : string);
  135.     { splits path spec into component parts. like Borland FSplit, but        }
  136.     { more liberal.                                                          }
  137.       Var k : byte;
  138.     Begin                                                        { filesplit }
  139.       drive := '';
  140.       dir := '';
  141.       name := '';
  142.       ext := '';
  143.       If (Length(path) >= 2) And (path[2] = ':') Then
  144.       Begin
  145.         drive := Copy(path,1,2);
  146.         Delete(path,1,2);
  147.       End;
  148.       k := Pos('\',path);
  149.       While k > 0 Do
  150.       Begin
  151.         dir := dir + Copy(path,1,k);
  152.         Delete(path,1,k);
  153.         k := Pos('\',path);
  154.       End;
  155.       name := path;
  156.       If name[1] = '.' Then Delete(name,1,1);
  157.       k := Pos('.',name);
  158.       If k > 0 Then
  159.       Begin
  160.         ext := Copy(name,k,255);
  161.         Delete(name,k,255);
  162.       End;
  163.     End;                                                         { filesplit }
  164.  
  165.   Begin                                                           { openfile }
  166.     temp := outname;
  167.     ok := True;
  168.     For i := Length(temp) DownTo 1 Do
  169.     Begin
  170.       If temp[i] = '.' Then
  171.       Begin
  172.         If Not ok Then temp[i] := '_';
  173.         ok := False;
  174.       End
  175.       Else
  176.       Begin
  177.         If temp[i] = '/' Then temp[i] := '\';
  178.         If temp[i] = '\' Then ok := True;
  179.         If temp[i] In badletter Then temp[i] := '_';
  180.         temp[i] := UpCase(temp[i]);
  181.       End;
  182.     End;
  183.     ok := False;
  184.     filesplit(temp,drive,dir,name,ext);
  185.     temp := '';
  186.     makedirs(temp,dir);
  187.     dir := temp;
  188.     If ext = '' Then ext := '.';
  189.     If Length(name) > 8 Then
  190.     Begin
  191.       If Length(ext) = 1 Then ext := '.' + Copy(name,9,3);
  192.       Delete(name,9,255);
  193.     End;
  194.     If name = '' Then
  195.     Begin
  196.       name := Copy(ext,2,255);
  197.       ext := '';
  198.     End;
  199.     If Length(ext) > 4 Then Delete(ext,5,255);
  200.     Repeat
  201.       Assign(outf,dir+name+ext);
  202.       Reset(outf,1);
  203.       If IOResult <> 0 Then ok := True
  204.       Else
  205.       Begin
  206.         Close(outf);
  207.         write(dir+name+ext,' already exists. Overwrite? (y/n) ');
  208.         Repeat
  209.           ch := UpCase(ReadKey);
  210.         Until ch In yesset + noset;
  211.         ok := ch in yesset;
  212.         write(CR);
  213.       End;
  214.       If Not ok Then
  215.       Begin
  216.         While Length(name) < 8 Do name := name + '0';
  217.         i := Length(name);
  218.         While (name[i] = '9') And (i > 1) Do
  219.         Begin
  220.           name[i] := '0';
  221.           Dec(i);
  222.         End;
  223.         If i = 0 Then abort('Cannot fix name '+outname,3);
  224.         If Not (name[i] In ['0'..'9']) Then name[i] := '0'
  225.                                        Else name[i] := Succ(name[i]);
  226.       End;
  227.     Until ok;
  228.     temp := dir + name + ext;
  229.     write('Original name: ',outname,', DOS name ',temp);
  230.     outname := temp;
  231.     Rewrite(outf,1);
  232.     IF IOResult <> 0 Then abort('Cannot output to file '+outname+'??',4);
  233.   End;                                                            { openfile }
  234.  
  235. Begin                                                                 { main }
  236.   writeln(progname,' ',version,' - extract files from a TAR');
  237.   writeln(copyright);
  238.   If ParamCount <> 1 Then usage;
  239.   tarname := ParamStr(1);
  240.   If Pos('.',tarname) = 0 Then tarname := tarname + '.TAR';
  241.   Assign(tar,tarname);
  242.   i := FileMode;
  243.   FileMode := 0;
  244.   Reset(tar,1);
  245.   FileMode := i;
  246.   If IORe